home *** CD-ROM | disk | FTP | other *** search
/ AmigActive 2 / AACD 2.iso / AACD / Programming / fpc / units / crt.pp < prev    next >
Text File  |  1998-09-21  |  26KB  |  1,022 lines
  1. {
  2.     $Id: crt.pp,v 1.5 1998/09/14 20:21:53 carl Exp $
  3.     This file is part of the Free Pascal run time library.
  4.     Copyright (c) 1998 by Nils Sjoholm and Carl Eric Codere
  5.  
  6.     See the file COPYING.FPC, included in this distribution,
  7.     for details about the copyright.
  8.  
  9.     This program is distributed in the hope that it will be useful,
  10.     but WITHOUT ANY WARRANTY; without even the implied warranty of
  11.     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  12.  
  13.  **********************************************************************}
  14.  
  15.  
  16. unit Crt;
  17.  
  18. {--------------------------------------------------------------------}
  19. { LEFT TO DO:                                                        }
  20. {--------------------------------------------------------------------}
  21. { o Write special characters are not recognized                      }
  22. { o Write does not take care of window coordinates yet.              }
  23. { o Read does not recognize the special editing characters           }
  24. { o Read does not take care of window coordinates yet.               }
  25. { o Readkey extended scancode is not correct yet                     }
  26. { o Color mapping only works for 4 colours                           }
  27. { o ClrScr, DeleteLine, InsLine do not work with window coordinates  }
  28. {--------------------------------------------------------------------}
  29.  
  30.  
  31.  
  32. Interface
  33.  
  34. Const
  35. { Controlling consts }
  36.   Flushing=false;                       {if true then don't buffer output}
  37.   ScreenWidth  = 80;
  38.   ScreenHeight = 25;
  39.  
  40. { CRT modes }
  41.   BW40          = 0;            { 40x25 B/W on Color Adapter }
  42.   CO40          = 1;            { 40x25 Color on Color Adapter }
  43.   BW80          = 2;            { 80x25 B/W on Color Adapter }
  44.   CO80          = 3;            { 80x25 Color on Color Adapter }
  45.   Mono          = 7;            { 80x25 on Monochrome Adapter }
  46.   Font8x8       = 256;          { Add-in for ROM font }
  47.  
  48. { Mode constants for 3.0 compatibility }
  49.   C40           = CO40;
  50.   C80           = CO80;
  51.  
  52. {
  53.   When using this color constants on the Amiga
  54.   you can bet that they don't work as expected.
  55.   You never know what color the user has on
  56.   his Amiga. Perhaps we should do a check of
  57.   the number of bitplanes (for number of colors)
  58.  
  59.   The normal 4 first pens for an Amiga are
  60.  
  61.   0 LightGrey
  62.   1 Black
  63.   2 White
  64.   3 Blue
  65.  
  66. }
  67.  
  68. { Foreground and background color constants  }
  69.   Black         = 1;  { normal pen for amiga }
  70.   Blue          = 3;  { windowborder color   }
  71.   Green         = 15;
  72.   Cyan          = 7;
  73.   Red           = 4;
  74.   Magenta       = 5;
  75.   Brown         = 6;
  76.   LightGray     = 0;  { canvas color         }
  77.  
  78. { Foreground color constants }
  79.   DarkGray      = 8;
  80.   LightBlue     = 9;
  81.   LightGreen    = 10;
  82.   LightCyan     = 11;
  83.   LightRed      = 12;
  84.   LightMagenta  = 13;
  85.   Yellow        = 14;
  86.   White         = 2;  { third color on amiga }
  87.  
  88. { Add-in for blinking }
  89.   Blink         = 128;
  90.  
  91. {Other Defaults}
  92.   LastMode   : Word = 3;
  93.   WindMin    : Word = $0;
  94.   WindMax    : Word = $184f;
  95. { These don't change anything if they are modified }
  96.   CheckSnow  : Boolean = FALSE;
  97.   DirectVideo: Boolean = FALSE;
  98. var
  99.   TextAttr : BYTE;
  100.   { CheckBreak have to make this one to a function for Amiga }
  101.   CheckEOF : Boolean;
  102.  
  103. Procedure AssignCrt(Var F: Text);
  104. Function  KeyPressed: Boolean;
  105. Function  ReadKey: Char;
  106. Procedure TextMode(Mode: Integer);
  107. Procedure Window(X1, Y1, X2, Y2: BYTE);
  108. Procedure GoToXy(X: byte; Y: byte);
  109. Function  WhereX: Byte;
  110. Function  WhereY: Byte;
  111. Procedure ClrScr;
  112. Procedure ClrEol;
  113. Procedure InsLine;
  114. Procedure DelLine;
  115. Procedure TextColor(Color: Byte);
  116. Procedure TextBackground(Color: Byte);
  117. Procedure LowVideo;
  118. Procedure HighVideo;
  119. Procedure NormVideo;
  120. Procedure Delay(DTime: Word);
  121. Procedure Sound(Hz: Word);
  122. Procedure NoSound;
  123.  
  124. { Extra functions }
  125.  
  126. Procedure CursorOn;
  127. Procedure CursorOff;
  128. Function CheckBreak: Boolean;
  129.  
  130. Implementation
  131.  
  132. {
  133.   The definitions of TextRec and FileRec are in separate files.
  134. }
  135. {$i textrec.inc}
  136. {$i filerec.inc}
  137.  
  138. var
  139.   maxcols,maxrows : longint;
  140.  
  141. CONST
  142.   { This is used to make sure that readkey returns immediately }
  143.   { if keypressed was used beforehand.                         }
  144.   KeyPress : char = #0;
  145.   _LVODisplayBeep = -96;
  146.  
  147.  
  148. Type
  149.  
  150.     pInfoData = ^tInfoData;
  151.     tInfoData = packed record
  152.         id_NumSoftErrors        : Longint;      { number of soft errors on disk }
  153.         id_UnitNumber           : Longint;      { Which unit disk is (was) mounted on }
  154.         id_DiskState            : Longint;      { See defines below }
  155.         id_NumBlocks            : Longint;      { Number of blocks on disk }
  156.         id_NumBlocksUsed        : Longint;      { Number of block in use }
  157.         id_BytesPerBlock        : Longint;
  158.         id_DiskType             : Longint;      { Disk Type code }
  159.         id_VolumeNode           : Longint;         { BCPL pointer to volume node }
  160.         id_InUse                : Longint;      { Flag, zero if not in use }
  161.     end;
  162.  
  163. { *  List Node Structure.  Each member in a list starts with a Node * }
  164.  
  165.   pNode = ^tNode;
  166.   tNode = packed Record
  167.     ln_Succ,                { * Pointer to next (successor) * }
  168.     ln_Pred  : pNode;       { * Pointer to previous (predecessor) * }
  169.     ln_Type  : Byte;
  170.     ln_Pri   : Shortint;    { * Priority, for sorting * }
  171.     ln_Name  : PChar;       { * ID string, null terminated * }
  172.   End;  { * Note: Integer aligned * }
  173.  
  174. { normal, full featured list }
  175.  
  176.     pList = ^tList;
  177.     tList = packed record
  178.     lh_Head     : pNode;
  179.     lh_Tail     : pNode;
  180.     lh_TailPred : pNode;
  181.     lh_Type     : Byte;
  182.     l_pad       : Byte;
  183.     end;
  184.  
  185.     pMsgPort = ^tMsgPort;
  186.     tMsgPort = packed record
  187.     mp_Node     : tNode;
  188.     mp_Flags    : Byte;
  189.     mp_SigBit   : Byte;      { signal bit number    }
  190.     mp_SigTask  : Pointer;   { task to be signalled (TaskPtr) }
  191.     mp_MsgList  : tList;     { message linked list  }
  192.     end;
  193.  
  194.     pMessage = ^tMessage;
  195.     tMessage = packed record
  196.     mn_Node       : tNode;
  197.     mn_ReplyPort  : pMsgPort;   { message reply port }
  198.     mn_Length     : Word;       { message len in bytes }
  199.     end;
  200.  
  201.     pIOStdReq = ^tIOStdReq;
  202.     tIOStdReq = packed record
  203.     io_Message  : tMessage;
  204.     io_Device   : Pointer;      { device node pointer  }
  205.     io_Unit     : Pointer;      { unit (driver private)}
  206.     io_Command  : Word;         { device command }
  207.     io_Flags    : Byte;
  208.     io_Error    : Shortint;     { error or warning num }
  209.     io_Actual   : Longint;      { actual number of bytes transferred }
  210.     io_Length   : Longint;      { requested number bytes transferred}
  211.     io_Data     : Pointer;      { points to data area }
  212.     io_Offset   : Longint;      { offset for block structured devices }
  213.     end;
  214.  
  215.     pIntuiMessage = ^tIntuiMessage;
  216.     tIntuiMessage = packed record
  217.         ExecMessage     : tMessage;
  218.         IClass          : Longint;
  219.         Code            : Word;
  220.         Qualifier       : Word;
  221.         IAddress        : Pointer;
  222.         MouseX,
  223.         MouseY          : Word;
  224.         Seconds,
  225.         Micros          : Longint;
  226.         IDCMPWindow     : Pointer;
  227.         SpecialLink     : pIntuiMessage;
  228.     end;
  229.  
  230.     pWindow = ^tWindow;
  231.     tWindow = packed record
  232.         NextWindow      : pWindow;      { for the linked list in a screen }
  233.         LeftEdge,
  234.         TopEdge         : Integer;      { screen dimensions of window }
  235.         Width,
  236.         Height          : Integer;      { screen dimensions of window }
  237.         MouseY,
  238.         MouseX          : Integer;      { relative to upper-left of window }
  239.         MinWidth,
  240.         MinHeight       : Integer;      { minimum sizes }
  241.         MaxWidth,
  242.         MaxHeight       : Word;         { maximum sizes }
  243.         Flags           : Longint;      { see below for defines }
  244.         MenuStrip       : Pointer;      { the strip of Menu headers }
  245.         Title           : PChar;        { the title text for this window }
  246.         FirstRequest    : Pointer;      { all active Requesters }
  247.         DMRequest       : Pointer;      { double-click Requester }
  248.         ReqCount        : Integer;      { count of reqs blocking Window }
  249.         WScreen         : Pointer;      { this Window's Screen }
  250.         RPort           : Pointer;      { this Window's very own RastPort }
  251.         BorderLeft,
  252.         BorderTop,
  253.         BorderRight,
  254.         BorderBottom    : Shortint;
  255.         BorderRPort     : Pointer;
  256.         FirstGadget     : Pointer;
  257.         Parent,
  258.         Descendant      : pWindow;
  259.         Pointer_        : Pointer;      { sprite data }
  260.         PtrHeight       : Shortint;     { sprite height (not including sprite padding) }
  261.         PtrWidth        : Shortint;     { sprite width (must be less than or equal to 16) }
  262.         XOffset,
  263.         YOffset         : Shortint;     { sprite offsets }
  264.         IDCMPFlags      : Longint;      { User-selected flags }
  265.         UserPort,
  266.         WindowPort      : pMsgPort;
  267.         MessageKey      : pIntuiMessage;
  268.         DetailPen,
  269.         BlockPen        : Byte;         { for bar/border/gadget rendering }
  270.         CheckMark       : Pointer;
  271.         ScreenTitle     : PChar;        { if non-null, Screen title when Window is active }
  272.         GZZMouseX       : Integer;
  273.         GZZMouseY       : Integer;
  274.         GZZWidth        : Integer;
  275.         GZZHeight       : Word;
  276.         ExtData         : Pointer;
  277.         UserData        : Pointer;      { general-purpose pointer to User data extension }
  278.         WLayer          : Pointer;
  279.         IFont           : Pointer;
  280.         MoreFlags       : Longint;
  281.     end;
  282.  
  283.     const
  284.  
  285.     M_LNM               = 20;           { linefeed newline mode }
  286.     PMB_ASM     = M_LNM + 1;    { internal storage bit for AS flag }
  287.     PMB_AWM     = PMB_ASM + 1;  { internal storage bit for AW flag }
  288.     MAXTABS     = 80;
  289.     IECLASS_MAX = $15;
  290.  
  291. type
  292.  
  293.     pKeyMap = ^tKeyMap;
  294.     tKeyMap = packed record
  295.         km_LoKeyMapTypes        : Pointer;
  296.         km_LoKeyMap             : Pointer;
  297.         km_LoCapsable           : Pointer;
  298.         km_LoRepeatable         : Pointer;
  299.         km_HiKeyMapTypes        : Pointer;
  300.         km_HiKeyMap             : Pointer;
  301.         km_HiCapsable           : Pointer;
  302.         km_HiRepeatable         : Pointer;
  303.     end;
  304.  
  305.  
  306.  
  307.     pConUnit = ^tConUnit;
  308.     tConUnit = packed record
  309.         cu_MP   : tMsgPort;
  310.         { ---- read only variables }
  311.         cu_Window       : Pointer;      { (WindowPtr) intuition window bound to this unit }
  312.         cu_XCP          : Integer;        { character position }
  313.         cu_YCP          : Integer;
  314.         cu_XMax         : Integer;        { max character position }
  315.         cu_YMax         : Integer;
  316.         cu_XRSize       : Integer;        { character raster size }
  317.         cu_YRSize       : Integer;
  318.         cu_XROrigin     : Integer;        { raster origin }
  319.         cu_YROrigin     : Integer;
  320.         cu_XRExtant     : Integer;        { raster maxima }
  321.         cu_YRExtant     : Integer;
  322.         cu_XMinShrink   : Integer;        { smallest area intact from resize process }
  323.         cu_YMinShrink   : Integer;
  324.         cu_XCCP         : Integer;        { cursor position }
  325.         cu_YCCP         : Integer;
  326.  
  327.    { ---- read/write variables (writes must must be protected) }
  328.    { ---- storage for AskKeyMap and SetKeyMap }
  329.  
  330.         cu_KeyMapStruct : tKeyMap;
  331.  
  332.    { ---- tab stops }
  333.  
  334.         cu_TabStops     : Array [0..MAXTABS-1] of Word;
  335.                                 { 0 at start, -1 at end of list }
  336.  
  337.    { ---- console rastport attributes }
  338.  
  339.         cu_Mask         : Shortint;
  340.         cu_FgPen        : Shortint;
  341.         cu_BgPen        : Shortint;
  342.         cu_AOLPen       : Shortint;
  343.         cu_DrawMode     : Shortint;
  344.         cu_AreaPtSz     : Shortint;
  345.         cu_AreaPtrn     : Pointer;      { cursor area pattern }
  346.         cu_Minterms     : Array [0..7] of Byte; { console minterms }
  347.         cu_Font         : Pointer;      { (TextFontPtr) }
  348.         cu_AlgoStyle    : Byte;
  349.         cu_TxFlags      : Byte;
  350.         cu_TxHeight     : Word;
  351.         cu_TxWidth      : Word;
  352.         cu_TxBaseline   : Word;
  353.         cu_TxSpacing    : Word;
  354.  
  355.    { ---- console MODES and RAW EVENTS switches }
  356.  
  357.         cu_Modes        : Array [0..(PMB_AWM+7) div 8 - 1] of Byte;
  358.                                 { one bit per mode }
  359.         cu_RawEvents    : Array [0..(IECLASS_MAX+7) div 8 - 1] of Byte;
  360.     end;
  361.  
  362. const
  363.  
  364.  
  365.    CD_CURRX =  1;
  366.    CD_CURRY =  2;
  367.    CD_MAXX  =  3;
  368.    CD_MAXY  =  4;
  369.  
  370.    CSI      = chr($9b);
  371.  
  372.    SIGBREAKF_CTRL_C = 4096;
  373.  
  374. function AllocVec( size, reqm : Longint ): Pointer;
  375. begin
  376.    asm
  377.        MOVE.L  A6,-(A7)
  378.        MOVE.L  size,d0
  379.        MOVE.L  reqm,d1
  380.        MOVE.L  _ExecBase, A6
  381.        JSR -684(A6)
  382.        MOVE.L  (A7)+,A6
  383.        MOVE.L  d0,@RESULT
  384.    end;
  385. end;
  386.  
  387.  
  388. function DoPkt(ID : pMsgPort;
  389.                Action, Param1, Param2,
  390.                Param3, Param4, Param5 : Longint) : Longint;
  391. begin
  392.    asm
  393.        MOVEM.L d2/d3/d4/d5/d6/d7/a6,-(A7)
  394.        MOVE.L  ID,d1
  395.        MOVE.L  Action,d2
  396.        MOVE.L  Param1,d3
  397.        MOVE.L  Param2,d4
  398.        MOVE.L  Param3,d5
  399.        MOVE.L  Param4,d6
  400.        MOVE.L  Param5,d7
  401.        MOVE.L  _DOSBase,A6
  402.        JSR -240(A6)
  403.        MOVEM.L (A7)+,d2/d3/d4/d5/d6/d7/a6
  404.        MOVE.L  d0,@RESULT
  405.    end;
  406. end;
  407.  
  408. procedure FreeVec( memory : Pointer );
  409. begin
  410.    asm
  411.        MOVE.L  A6,-(A7)
  412.        MOVE.L  memory,a1
  413.        MOVE.L  _ExecBase,A6
  414.        JSR -690(A6)
  415.        MOVE.L  (A7)+,A6
  416.    end;
  417. end;
  418.  
  419.  
  420. function GetConsoleTask : pMsgPort;
  421. begin
  422.    asm
  423.        MOVE.L  A6,-(A7)
  424.        MOVE.L  _DOSBase,A6
  425.        JSR -510(A6)
  426.        MOVE.L  (A7)+,A6
  427.        MOVE.L  d0,@RESULT
  428.    end;
  429. end;
  430.  
  431.  
  432. function GetMsg(port : pMsgPort): pMessage;
  433. begin
  434.    asm
  435.        MOVE.L  A6,-(A7)
  436.        MOVE.L  port,a0
  437.        MOVE.L  _ExecBase,A6
  438.        JSR -372(A6)
  439.        MOVE.L  (A7)+,A6
  440.        MOVE.L  d0,@RESULT
  441.    end;
  442. end;
  443.  
  444. function ModifyIDCMP(window : pWindow;
  445.                      IDCMPFlags : Longint) : Boolean;
  446. begin
  447.    asm
  448.        MOVE.L  A6,-(A7)
  449.        MOVE.L  window,a0
  450.        MOVE.L  IDCMPFlags,d0
  451.        MOVE.L  _IntuitionBase,A6
  452.        JSR -150(A6)
  453.        MOVE.L  (A7)+,A6
  454.        TST.L   d0
  455.        bne     @success
  456.        bra     @end
  457.    @success:
  458.        move.b  #1,d0
  459.    @end:
  460.        move.b  d0,@RESULT
  461.    end;
  462. end;
  463.  
  464. procedure ReplyMsg(mess : pMessage);
  465. begin
  466.    asm
  467.        MOVE.L  A6,-(A7)
  468.        MOVE.L  mess,a1
  469.        MOVE.L  _ExecBase,A6
  470.        JSR -378(A6)
  471.        MOVE.L  (A7)+,A6
  472.    end;
  473. end;
  474.  
  475.  
  476. function WaitPort(port : pMsgPort): pMessage;
  477. begin
  478.    asm
  479.        MOVE.L  A6,-(A7)
  480.        MOVE.L  port,a0
  481.        MOVE.L  _ExecBase,A6
  482.        JSR -384(A6)
  483.        MOVE.L  (A7)+,A6
  484.        MOVE.L  d0,@RESULT
  485.    end;
  486. end;
  487.  
  488. procedure Delay_(ticks : Longint);
  489. begin
  490.    asm
  491.        MOVE.L  A6,-(A7)
  492.        MOVE.L  ticks,d1
  493.        MOVE.L  _DOSBase,A6
  494.        JSR -198(A6)
  495.        MOVE.L  (A7)+,A6
  496.    end;
  497. end;
  498.  
  499. function SetSignal(newSignals, signalMask : Longint) : Longint;
  500. begin
  501.    asm
  502.        MOVE.L  A6,-(A7)
  503.        MOVE.L  newSignals,d0
  504.        MOVE.L  signalMask,d1
  505.        MOVE.L  _ExecBase,A6
  506.        JSR -306(A6)
  507.        MOVE.L  (A7)+,A6
  508.        MOVE.L  d0,@RESULT
  509.    end;
  510. end;
  511.  
  512. function OpenInfo : pInfoData;
  513. var
  514.    port     :  pMsgPort;
  515.    info     :  pInfoData;
  516.    bptr, d4, d5, d6, d7 :  Longint;
  517. begin
  518.    info  := pInfoData(AllocVec(SizeOf(tInfoData), 1));
  519.  
  520.    if info <> nil then begin
  521.       port  := GetConsoleTask;
  522.       bptr  := Longint(info) shr 2;
  523.  
  524.       if port <> nil then begin
  525.          if DoPkt(port, $19, bptr, d4, d5, d6, d7) <> 0 then info := pInfoData(bptr shl 2)
  526.          else port := nil;
  527.       end;
  528.  
  529.       if port = nil then begin
  530.          FreeVec(info);
  531.          info := nil;
  532.       end;
  533.    end;
  534.  
  535.    OpenInfo := info;
  536. end;
  537.  
  538. procedure CloseInfo(var info : pInfoData);
  539. begin
  540.    if info <> nil then begin
  541.       FreeVec(info);
  542.       info := nil;
  543.    end;
  544. end;
  545.  
  546. function ConData(modus : byte) : integer;
  547. var
  548.    info  :  pInfoData;
  549.    theunit  :  pConUnit;
  550.    pos   :  Longint;
  551. begin
  552.    pos   := 1;
  553.    info  := OpenInfo;
  554.  
  555.    if info <> nil then begin
  556.       theunit  := pConUnit((pIoStdReq(info^.id_InUse))^.io_Unit);
  557.  
  558.       case modus of
  559.          CD_CURRX :  pos   := theunit^.cu_XCP;
  560.          CD_CURRY :  pos   := theunit^.cu_YCP;
  561.          CD_MAXX  :  pos   := theunit^.cu_XMax;
  562.          CD_MAXY  :  pos   := theunit^.cu_YMax;
  563.       end;
  564.  
  565.       CloseInfo(info);
  566.    end;
  567.  
  568.    ConData := pos + 1;
  569. end;
  570.  
  571. function WhereX : Byte;
  572. begin
  573.    WhereX := Byte(ConData(CD_CURRX))-lo(windmin);
  574. end;
  575.  
  576. function realx: byte;
  577. begin
  578.    RealX := Byte(ConData(CD_CURRX));
  579. end;
  580.  
  581. function realy: byte;
  582. begin
  583.  RealY := Byte(ConData(CD_CURRY));
  584. end;
  585.  
  586. function WhereY : Byte;
  587. begin
  588.    WhereY := Byte(ConData(CD_CURRY))-hi(windmin);
  589. end;
  590.  
  591. function screencols : integer;
  592. begin
  593.    screencols := ConData(CD_MAXX);
  594. end;
  595.  
  596. function screenrows : integer;
  597. begin
  598.    screenrows := ConData(CD_MAXY);
  599. end;
  600.  
  601.  
  602.  procedure Realgotoxy(x,y : integer);
  603.  begin
  604.        Write(CSI, y, ';', x, 'H');
  605.  end;
  606.  
  607.  
  608.  procedure gotoxy(x,y : byte);
  609.  begin
  610.         if (x<1) then
  611.           x:=1;
  612.         if (y<1) then
  613.           y:=1;
  614.         if y+hi(windmin)-2>=hi(windmax) then
  615.           y:=hi(windmax)-hi(windmin)+1;
  616.         if x+lo(windmin)-2>=lo(windmax) then
  617.           x:=lo(windmax)-lo(windmin)+1;
  618.         Write(CSI, y+hi(windmin), ';', x+lo(windmin), 'H');
  619.  end;
  620.  
  621.  
  622. procedure CursorOff;
  623. begin
  624.    Write(CSI,'0 p');
  625. end;
  626.  
  627. procedure CursorOn;
  628. begin
  629.    Write(CSI,'1 p');
  630. end;
  631.  
  632. procedure ClrScr;
  633. begin
  634.    Write(Chr($0c));
  635. end;
  636.  
  637. function ReadKey : char;
  638. const
  639.    IDCMP_VANILLAKEY = $00200000;
  640.    IDCMP_RAWKEY     = $00000400;
  641. var
  642.    info  :  pInfoData;
  643.    win   :  pWindow;
  644.    imsg  :  pIntuiMessage;
  645.    msg   :  pMessage;
  646.    key   :  char;
  647.    idcmp, vanil   :  Longint;
  648. begin
  649.    key   := #0;
  650.    if KeyPress <> #0 then
  651.     Begin
  652.       ReadKey:=KeyPress;
  653.       KeyPress:=#0;
  654.       exit;
  655.     end;
  656.    info  := OpenInfo;
  657.  
  658.    if info <> nil then begin
  659.       win   := pWindow(pConUnit((pIoStdReq(info^.id_InUse))^.io_Unit)^.cu_Window);
  660.       idcmp := win^.IDCMPFlags;
  661.       vanil := IDCMP_VANILLAKEY or IDCMP_RAWKEY;
  662.  
  663.       ModifyIDCMP(win, (idcmp or vanil));
  664.  
  665.       repeat
  666.          msg   := WaitPort(win^.UserPort);
  667.          imsg  := pIntuiMessage(GetMsg(win^.UserPort));
  668.  
  669.          if (imsg^.IClass = IDCMP_VANILLAKEY) then
  670.               key := char(imsg^.Code)
  671.          else
  672.          if (imsg^.IClass = IDCMP_RAWKEY) then
  673.               key := char(imsg^.Code);
  674.  
  675.          ReplyMsg(pMessage(imsg));
  676.       until key <> #0;
  677.  
  678.       repeat
  679.          msg   := GetMsg(win^.UserPort);
  680.  
  681.          if msg <> nil then ReplyMsg(msg);
  682.       until msg = nil;
  683.  
  684.       ModifyIDCMP(win, idcmp);
  685.  
  686.       CloseInfo(info);
  687.    end;
  688.  
  689.    ReadKey := key;
  690. end;
  691.  
  692. function KeyPressed : Boolean;
  693. const
  694.    IDCMP_VANILLAKEY = $00200000;
  695.    IDCMP_RAWKEY     = $00000400;
  696. var
  697.    info  :  pInfoData;
  698.    win   :  pWindow;
  699.    imsg  :  pIntuiMessage;
  700.    msg   :  pMessage;
  701.    idcmp, vanil   :  Longint;
  702.    ispressed : Boolean;
  703. begin
  704.    KeyPress := #0;
  705.    ispressed := False;
  706.    info  := OpenInfo;
  707.  
  708.    if info <> nil then begin
  709.       win   := pWindow(pConUnit((pIoStdReq(info^.id_InUse))^.io_Unit)^.cu_Window);
  710.       idcmp := win^.IDCMPFlags;
  711.       vanil := IDCMP_VANILLAKEY or IDCMP_RAWKEY;
  712.  
  713.       ModifyIDCMP(win, (idcmp or vanil));
  714.  
  715.       msg   := WaitPort(win^.UserPort);
  716.       imsg  := pIntuiMessage(GetMsg(win^.UserPort));
  717.  
  718.       if (imsg^.IClass = IDCMP_VANILLAKEY) or (imsg^.IClass = IDCMP_RAWKEY) then
  719.       Begin
  720.         ispressed := true;
  721.         KeyPress := char(imsg^.Code)
  722.       end;
  723.  
  724.       ReplyMsg(pMessage(imsg));
  725.  
  726.       repeat
  727.          msg   := GetMsg(win^.UserPort);
  728.  
  729.          if msg <> nil then ReplyMsg(msg);
  730.       until msg = nil;
  731.  
  732.       ModifyIDCMP(win, idcmp);
  733.  
  734.       CloseInfo(info);
  735.    end;
  736.  
  737.    KeyPressed := ispressed;
  738. end;
  739.  
  740. procedure TextColor(color : byte);
  741. begin
  742.    TextAttr := (TextAttr and $70) or color;
  743.    Write(CSI, '3', color, 'm');
  744. end;
  745.  
  746. procedure TextBackground(color : byte);
  747. begin
  748.    Textattr:=(textattr and $8f) or ((color and $7) shl 4);
  749.    Write(CSI, '4', color, 'm');
  750. end;
  751.  
  752. procedure Window(X1,Y1,X2,Y2: Byte);
  753.  begin
  754.    if (x1<1) or (x2>screencols) or (y2>screenrows) or
  755.      (x1>x2) or (y1>y2) then
  756.        exit;
  757.    windmin:=(x1-1) or ((y1-1) shl 8);
  758.    windmax:=(x2-1) or ((y2-1) shl 8);
  759.    gotoxy(1,1);
  760.  end;
  761.  
  762.  
  763.  
  764.  
  765.  
  766. procedure DelLine;
  767. begin
  768.    Write(CSI,'X');
  769. end;
  770.  
  771. procedure ClrEol;
  772. begin
  773.    Write(CSI,'K');
  774. end;
  775.  
  776. procedure InsLine;
  777. begin
  778.    Write(CSI,'1 L');
  779. end;
  780.  
  781. procedure cursorbig;
  782. begin
  783. end;
  784.  
  785. procedure lowvideo;
  786. begin
  787. end;
  788.  
  789. procedure highvideo;
  790. begin
  791. end;
  792.  
  793. procedure nosound;
  794. begin
  795. end;
  796.  
  797. procedure sound(hz : word);
  798. begin
  799. end;
  800.  
  801. procedure delay(DTime : Word);
  802. var
  803.     dummy : Longint;
  804. begin
  805.     dummy := trunc((real(DTime) / 1000.0) * 50.0);
  806.     Delay_(dummy);
  807. end;
  808.  
  809. function CheckBreak : boolean;
  810. begin
  811.    if (SetSignal(0, 0) and SIGBREAKF_CTRL_C) = SIGBREAKF_CTRL_C then
  812.       CheckBreak := true
  813.    else
  814.       CheckBreak := false;
  815. end;
  816.  
  817. procedure textmode(mode : integer);
  818. begin
  819.        lastmode:=mode;
  820.        mode:=mode and $ff;
  821.        windmin:=0;
  822.        windmax:=(screencols-1) or ((screenrows-1) shl 8);
  823.        maxcols:=screencols;
  824.        maxrows:=screenrows;
  825. end;
  826.  
  827. procedure normvideo;
  828. begin
  829. end;
  830.  
  831. function GetTextBackground : byte;
  832. var
  833.    info  :  pInfoData;
  834.    pen   :  byte;
  835. begin
  836.    pen   := 1;
  837.    info  := OpenInfo;
  838.  
  839.    if info <> nil then begin
  840.       pen   := pConUnit((pIoStdReq(info^.id_InUse))^.io_Unit)^.cu_BgPen;
  841.  
  842.       CloseInfo(info);
  843.    end;
  844.  
  845.    GetTextBackground := pen;
  846. end;
  847.  
  848. function GetTextColor : byte;
  849. var
  850.    info  :  pInfoData;
  851.    pen   :  byte;
  852. begin
  853.    pen   := 1;
  854.    info  := OpenInfo;
  855.  
  856.    if info <> nil then begin
  857.       pen   := pConUnit((pIoStdReq(info^.id_InUse))^.io_Unit)^.cu_FgPen;
  858.  
  859.       CloseInfo(info);
  860.    end;
  861.  
  862.    GetTextColor   := pen;
  863. end;
  864.  
  865.  
  866. {*****************************************************************************
  867.                           Read and Write routines
  868. *****************************************************************************}
  869. { Problem here: Currently all these routines are not implemented because of how }
  870. { the console device works. Because w low level write is required to change the }
  871. { position of the cursor, and since the CrtWrite is assigned as the standard    }
  872. { write routine, a recursive call will occur                                    }
  873.  
  874. { How to fix this:                                                              }
  875. {  At startup make a copy of the Output handle, and then use this copy to make  }
  876. {  low level positioning calls. This does not seem to work yet.                 }
  877.  
  878.  
  879.  
  880.    Function CrtWrite(var f : textrec):integer;
  881.  
  882.       var
  883.          i,col,row : longint;
  884.          c : char;
  885.          buf: array[0..1] of char;
  886.  
  887.       begin
  888.          col:=realx;
  889.          row:=realy;
  890.          inc(row);
  891.          inc(col);
  892.          for i:=0 to f.bufpos-1 do
  893.            begin
  894.               c:=f.buffer[i];
  895.               case ord(c) of
  896.                  10 : begin
  897.                          inc(row);
  898.                       end;
  899.                  13 : begin
  900.                          col:=lo(windmin)+1;
  901.                      end;
  902.                  8 : if col>lo(windmin)+1 then
  903.                        begin
  904.                           dec(col);
  905.                        end;
  906.                  7 : begin
  907.                          { beep }
  908.                          asm
  909.                            move.l a6,d6               { save base pointer    }
  910.                            move.l _IntuitionBase,a6   { set library base     }
  911.                            sub.l  a0,a0
  912.                            jsr    _LVODisplayBeep(a6)
  913.                            move.l d6,a6               { restore base pointer }
  914.                          end;
  915.                       end;
  916.               else
  917.                  begin
  918.                    buf[0]:=c;
  919.                    realgotoxy(row,col);
  920.                    do_write(f.handle,longint(@buf[0]),1);
  921.                    inc(col);
  922.                  end;
  923.               end;
  924.               if col>lo(windmax)+1 then
  925.                 begin
  926.                    col:=lo(windmin)+1;
  927.                    inc(row);
  928.                 end;
  929.               while row>hi(windmax)+1 do
  930.                 begin
  931.                    delline;
  932.                    dec(row);
  933.                 end;
  934.            end;
  935.          f.bufpos:=0;
  936.          realgotoxy(row-1,col-1);
  937.          CrtWrite:=0;
  938.       end;
  939.  
  940.    Function CrtClose(Var F: TextRec): Integer;
  941.      Begin
  942.        F.Mode:=fmClosed;
  943.        CrtClose:=0;
  944.      End;
  945.  
  946.    Function CrtOpen(Var F: TextRec): Integer;
  947.      Begin
  948.        If F.Mode = fmOutput Then
  949.         CrtOpen:=0
  950.        Else
  951.         CrtOpen:=5;
  952.      End;
  953.  
  954.    Function CrtRead(Var F: TextRec): Integer;
  955.      Begin
  956.        f.bufend:=do_read(f.handle,longint(f.bufptr),f.bufsize);
  957.        f.bufpos:=0;
  958.        CrtRead:=0;
  959.      End;
  960.  
  961.    Function CrtInOut(Var F: TextRec): Integer;
  962.      Begin
  963.        Case F.Mode of
  964.         fmInput: CrtInOut:=CrtRead(F);
  965.         fmOutput: CrtInOut:=CrtWrite(F);
  966.        End;
  967.      End;
  968.  
  969.    procedure assigncrt(var f : text);
  970.      begin
  971.    {     TextRec(F).Mode:=fmClosed;
  972.         TextRec(F).BufSize:=SizeOf(TextBuf);
  973.         TextRec(F).BufPtr:=@TextRec(F).Buffer;
  974.         TextRec(F).BufPos:=0;
  975.         TextRec(F).OpenFunc:=@CrtOpen;
  976.         TextRec(F).InOutFunc:=@CrtInOut;
  977.         TextRec(F).FlushFunc:=@CrtInOut;
  978.         TextRec(F).CloseFunc:=@CrtClose;
  979.         TextRec(F).Name[0]:='.';
  980.         TextRec(F).Name[1]:=#0;}
  981.      end;
  982.  
  983.  
  984. var
  985.   old_exit : pointer;
  986.  
  987. procedure crt_exit;
  988. begin
  989.   { Restore default colors }
  990.   write(CSI,'0m');
  991.   exitproc:=old_exit;
  992. end;
  993.  
  994.  
  995. Begin
  996.    old_exit:=exitproc;
  997.    exitproc:=@crt_exit;
  998.    { load system variables to temporary variables to save time }
  999.    maxcols:=screencols;
  1000.    maxrows:=screenrows;
  1001.    { Set the initial text attributes }
  1002.    { Text background }
  1003.    Textattr:=(textattr and $8f) or ((GetTextBackGround and $7) shl 4);
  1004.    { Text foreground }
  1005.    TextAttr := (TextAttr and $70) or GetTextColor;
  1006.    { set output window }
  1007.    windmax:=(maxcols-1) or (( maxrows-1) shl 8);
  1008.  
  1009.  
  1010.    { Get a copy of the standard      }
  1011.    { output handle, and when using   }
  1012.    { direct console calls, use this  }
  1013.    { handle instead.                 }
  1014. {   assigncrt(Output);
  1015.    TextRec(Output).mode:=fmOutput;}
  1016. end.
  1017.  
  1018.  
  1019.  
  1020.  
  1021.  
  1022.